home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / lib / tclX-6.4 / tcl.tlib < prev    next >
Encoding:
Text File  |  1992-12-17  |  16.0 KB  |  662 lines
  1.  
  2. #@package: TclX-ArrayProcedures for_array_keys
  3.  
  4. proc for_array_keys {varName arrayName codeFragment} {
  5.     upvar $varName enumVar $arrayName enumArray
  6.  
  7.     if ![info exists enumArray] {
  8.     error "\"$arrayName\" isn't an array"
  9.     }
  10.  
  11.     set searchId [array startsearch enumArray]
  12.     while {[array anymore enumArray $searchId]} {
  13.     set enumVar [array nextelement enumArray $searchId]
  14.     uplevel $codeFragment
  15.     }
  16.     array donesearch enumArray $searchId
  17. }
  18.  
  19. #@package: TclX-assign_fields assign_fields
  20.  
  21. proc assign_fields {list args} {
  22.     foreach varName $args {
  23.         set value [lvarpop list]
  24.         uplevel "set $varName [list $value]"
  25.     }
  26. }
  27.  
  28. #@package: TclX-developer_utils saveprocs edprocs
  29.  
  30. proc saveprocs {fileName args} {
  31.     set fp [open $fileName w]
  32.     puts $fp "# tcl procs saved on [fmtclock [getclock]]\n"
  33.     puts $fp [eval "showprocs $args"]
  34.     close $fp
  35. }
  36.  
  37. proc edprocs {args} {
  38.     global env
  39.  
  40.     set tmpFilename /tmp/tcldev.[id process]
  41.  
  42.     set fp [open $tmpFilename w]
  43.     puts $fp "\n# TEMP EDIT BUFFER -- YOUR CHANGES ARE FOR THIS SESSION ONLY\n"
  44.     puts $fp [eval "showprocs $args"]
  45.     close $fp
  46.  
  47.     if [info exists env(EDITOR)] {
  48.         set editor $env(EDITOR)
  49.     } else {
  50.     set editor vi
  51.     }
  52.  
  53.     set startMtime [file mtime $tmpFilename]
  54.     system "$editor $tmpFilename"
  55.  
  56.     if {[file mtime $tmpFilename] != $startMtime} {
  57.     source $tmpFilename
  58.     echo "Procedures were reloaded."
  59.     } else {
  60.     echo "No changes were made."
  61.     }
  62.     unlink $tmpFilename
  63.     return
  64. }
  65.  
  66. #@package: TclX-forfile for_file
  67.  
  68. proc for_file {var filename code} {
  69.     upvar $var line
  70.     set fp [open $filename r]
  71.     while {[gets $fp line] >= 0} {
  72.         uplevel $code
  73.     }
  74.     close $fp
  75. }
  76.  
  77.  
  78. #@package: TclX-forrecur for_recursive_glob
  79.  
  80. proc for_recursive_glob {var globlist code {depth 1}} {
  81.     upvar $depth $var myVar
  82.     foreach globpat $globlist {
  83.         foreach file [glob -nocomplain $globpat] {
  84.             if [file isdirectory $file] {
  85.                 for_recursive_glob $var $file/* $code [expr {$depth + 1}]
  86.         }
  87.         set myVar $file
  88.         uplevel $depth $code
  89.         }
  90.     }
  91. }
  92.  
  93. #@package: TclX-globrecur recursive_glob
  94.  
  95. proc recursive_glob {globlist} {
  96.     set result ""
  97.     foreach pattern $globlist {
  98.         foreach file [glob -nocomplain $pattern] {
  99.             lappend result $file
  100.             if [file isdirectory $file] {
  101.                 set result [concat $result [recursive_glob $file/*]]
  102.             }
  103.         }
  104.     }
  105.     return $result
  106. }
  107.  
  108. #@package: TclX-help help helpcd helppwd apropos
  109.  
  110.  
  111. proc help:flattenPath {pathName} {
  112.     set newPath {}
  113.     foreach element [split $pathName /] {
  114.         if {"$element" == "."} {
  115.            continue
  116.         }
  117.         if {"$element" == ".."} {
  118.             if {[llength [join $newPath /]] == 0} {
  119.                 error "Help: name goes above subject directory root"}
  120.             lvarpop newPath [expr [llength $newPath]-1]
  121.             continue
  122.         }
  123.         lappend newPath $element
  124.     }
  125.     set newPath [join $newPath /]
  126.     
  127.  
  128.     if {("$newPath" == "") && [string match "/*" $pathName]} {
  129.         set newPath "/"}
  130.         
  131.     return $newPath
  132. }
  133.  
  134.  
  135. proc help:EvalPath {pathName} {
  136.     global TCLENV
  137.  
  138.     if {![string match "/*" $pathName]} {
  139.         if {"$pathName" == ""} {
  140.             return $TCLENV(help:curDir)}
  141.         if {"$TCLENV(help:curDir)" == "/"} {
  142.             set pathName "/$pathName"
  143.         } else {
  144.             set pathName "$TCLENV(help:curDir)/$pathName"
  145.         }
  146.     }
  147.     set pathName [help:flattenPath $pathName]
  148.     if {[string match "*/" $pathName] && ($pathName != "/")} {
  149.         set pathName [csubstr $pathName 0 [expr [length $pathName]-1]]}
  150.  
  151.     return $pathName    
  152. }
  153.  
  154.  
  155. proc help:Display {line} {
  156.     global TCLENV
  157.     if {$TCLENV(help:lineCnt) >= 23} {
  158.         set TCLENV(help:lineCnt) 0
  159.         puts stdout ":" nonewline
  160.         flush stdout
  161.         gets stdin response
  162.         if {![lempty $response]} {
  163.             return 0}
  164.     }
  165.     puts stdout $line
  166.     incr TCLENV(help:lineCnt)
  167. }
  168.  
  169.  
  170. proc help:DisplayFile {filepath} {
  171.  
  172.     set inFH [open $filepath r]
  173.     while {[gets $inFH fileBuf] >= 0} {
  174.         if {![help:Display $fileBuf]} {
  175.             break}
  176.     }
  177.     close $inFH
  178.  
  179. }    
  180.  
  181.  
  182. proc help:ListDir {dirPath} {
  183.     set dirList {}
  184.     set fileList {}
  185.     if {[catch {set dirFiles [glob $dirPath/*]}] != 0} {
  186.         error "No files in subject directory: $dirPath"}
  187.     foreach fileName $dirFiles {
  188.         if [file isdirectory $fileName] {
  189.             lappend dirList "[file tail $fileName]/"
  190.         } else {
  191.             lappend fileList [file tail $fileName]
  192.         }
  193.     }
  194.    return [list [lsort $dirList] [lsort $fileList]]
  195. }
  196.  
  197.  
  198. proc help:DisplayColumns {nameList} {
  199.     set count 0
  200.     set outLine ""
  201.     foreach name $nameList {
  202.         if {$count == 0} {
  203.             append outLine "   "}
  204.         append outLine $name
  205.         if {[incr count] < 4} {
  206.             set padLen [expr 17-[clength $name]]
  207.             if {$padLen < 3} {
  208.                set padLen 3}
  209.             append outLine [replicate " " $padLen]
  210.         } else {
  211.            if {![help:Display $outLine]} {
  212.                return}
  213.            set outLine ""
  214.            set count 0
  215.         }
  216.     }
  217.     if {$count != 0} {
  218.         help:Display $outLine}
  219.     return
  220. }
  221.  
  222.  
  223.  
  224. proc help {{subject {}}} {
  225.     global TCLENV
  226.  
  227.     set TCLENV(help:lineCnt) 0
  228.  
  229.  
  230.     if {($subject == "help") || ($subject == "?")} {
  231.         help:DisplayFile "$TCLENV(help:root)/help"
  232.         return
  233.     }
  234.  
  235.     set request [help:EvalPath $subject]
  236.     set requestPath "$TCLENV(help:root)$request"
  237.  
  238.     if {![file exists $requestPath]} {
  239.         error "Help:\"$request\" does not exist"}
  240.     
  241.     if [file isdirectory $requestPath] {
  242.         set dirList [help:ListDir $requestPath]
  243.         set subList  [lindex $dirList 0]
  244.         set fileList [lindex $dirList 1]
  245.         if {[llength $subList] != 0} {
  246.             help:Display "\nSubjects available in $request:"
  247.             help:DisplayColumns $subList
  248.         }
  249.         if {[llength $fileList] != 0} {
  250.             help:Display "\nHelp files available in $request:"
  251.             help:DisplayColumns $fileList
  252.         }
  253.     } else {
  254.         help:DisplayFile $requestPath
  255.     }
  256.     return
  257. }
  258.  
  259.  
  260.  
  261. proc helpcd {{dir /}} {
  262.     global TCLENV
  263.  
  264.     set request [help:EvalPath $dir]
  265.     set requestPath "$TCLENV(help:root)$request"
  266.  
  267.     if {![file exists $requestPath]} {
  268.         error "Helpcd: \"$request\" does not exist"}
  269.     
  270.     if {![file isdirectory $requestPath]} {
  271.         error "Helpcd: \"$request\" is not a directory"}
  272.  
  273.     set TCLENV(help:curDir) $request
  274.     return    
  275. }
  276.  
  277.  
  278. proc helppwd {} {
  279.         global TCLENV
  280.         echo "Current help subject directory: $TCLENV(help:curDir)"
  281. }
  282.  
  283.  
  284. proc apropos {name} {
  285.     global TCLENV
  286.  
  287.     set TCLENV(help:lineCnt) 0
  288.  
  289.     set aproposCT [scancontext create]
  290.     scanmatch -nocase $aproposCT $name {
  291.         set path [lindex $matchInfo(line) 0]
  292.         set desc [lrange $matchInfo(line) 1 end]
  293.         if {![help:Display [format "%s - %s" $path $desc]]} {
  294.             return}
  295.     }
  296.     foreach brief [glob -nocomplain $TCLENV(help:root)/*.brf] {
  297.         set briefFH [open $brief]
  298.         scanfile $aproposCT $briefFH
  299.         close $briefFH
  300.     }
  301.     scancontext delete $aproposCT
  302. }
  303.  
  304. global TCLENV TCLPATH
  305.  
  306. set TCLENV(help:root) [searchpath $TCLPATH help]
  307. set TCLENV(help:curDir) "/"
  308. set TCLENV(help:outBuf) {}
  309.  
  310. #@package: TclX-packages packages autoprocs
  311.  
  312. proc packages {{option {}}} {
  313.     global TCLENV
  314.     set packList {}
  315.     foreach key [array names TCLENV] {
  316.         if {[string match "PKG:*" $key]} {
  317.             lappend packList [string range $key 4 end]
  318.         }
  319.     }
  320.     if [lempty $option] {
  321.         return $packList
  322.     } else {
  323.         if {$option != "-location"} {
  324.             error "Unknow option \"$option\", expected \"-location\""
  325.         }
  326.         set locList {}
  327.         foreach pack $packList {
  328.             set fileId [lindex $TCLENV(PKG:$pack) 0]
  329.             
  330.             lappend locList [list $pack [concat $TCLENV($fileId) \
  331.                                              [lrange $TCLENV(PKG:$pack) 1 2]]]
  332.         }
  333.         return $locList
  334.     }
  335. }
  336.  
  337. proc autoprocs {} {
  338.     global TCLENV
  339.     set procList {}
  340.     foreach key [array names TCLENV] {
  341.         if {[string match "PROC:*" $key]} {
  342.             lappend procList [string range $key 5 end]
  343.         }
  344.     }
  345.     return $procList
  346. }
  347.  
  348. #@package: TclX-directory_stack pushd popd dirs
  349.  
  350. global TCLENV(dirPushList)
  351.  
  352. set TCLENV(dirPushList) ""
  353.  
  354. proc pushd {args} {
  355.     global TCLENV
  356.  
  357.     if {[llength $args] > 1} {
  358.         error "bad # args: pushd [dir_to_cd_to]"
  359.     }
  360.     set TCLENV(dirPushList) [linsert $TCLENV(dirPushList) 0 [pwd]]
  361.  
  362.     if {[llength $args] != 0} {
  363.         cd [glob $args]
  364.     }
  365. }
  366.  
  367. proc popd {} {
  368.     global TCLENV
  369.  
  370.     if [llength $TCLENV(dirPushList)] {
  371.         cd [lvarpop TCLENV(dirPushList)]
  372.         pwd
  373.     } else {
  374.         error "directory stack empty"
  375.     }
  376. }
  377.  
  378. proc dirs {} { 
  379.     global TCLENV
  380.     echo [pwd] $TCLENV(dirPushList)
  381. }
  382.  
  383. #@package: TclX-set_functions union intersect intersect3 lrmdups
  384.  
  385. proc union {lista listb} {
  386.     set full_list [lsort [concat $lista $listb]]
  387.     set check_element [lindex $full_list 0]
  388.     set outlist $check_element
  389.     foreach element [lrange $full_list 1 end] {
  390.     if {$check_element == $element} continue
  391.     lappend outlist $element
  392.     set check_element $element
  393.     }
  394.     return $outlist
  395. }
  396.  
  397. proc lrmdups {list} {
  398.     set list [lsort $list]
  399.     set result [lvarpop list]
  400.     lappend last $result
  401.     foreach element $list {
  402.     if {$last != $element} {
  403.         lappend result $element
  404.         set last $element
  405.     }
  406.     }
  407.     return $result
  408. }
  409.  
  410.  
  411. proc intersect3 {list1 list2} {
  412.     set list1Result ""
  413.     set list2Result ""
  414.     set intersectList ""
  415.  
  416.     set list1 [lrmdups $list1]
  417.     set list2 [lrmdups $list2]
  418.  
  419.     while {1} {
  420.         if [lempty $list1] {
  421.             if ![lempty $list2] {
  422.                 set list2Result [concat $list2Result $list2]
  423.             }
  424.             break
  425.         }
  426.         if [lempty $list2] {
  427.         set list1Result [concat $list1Result $list1]
  428.             break
  429.         }
  430.         set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]
  431.  
  432.         if {$compareResult < 0} {
  433.             lappend list1Result [lvarpop list1]
  434.             continue
  435.         }
  436.         if {$compareResult > 0} {
  437.             lappend list2Result [lvarpop list2]
  438.             continue
  439.         }
  440.         lappend intersectList [lvarpop list1]
  441.         lvarpop list2
  442.     }
  443.     return [list $list1Result $intersectList $list2Result]
  444. }
  445.  
  446. proc intersect {list1 list2} {
  447.     set intersectList ""
  448.  
  449.     set list1 [lsort $list1]
  450.     set list2 [lsort $list2]
  451.  
  452.     while {1} {
  453.         if {[lempty $list1] || [lempty $list2]} break
  454.  
  455.         set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]
  456.  
  457.         if {$compareResult < 0} {
  458.             lvarpop list1
  459.             continue
  460.         }
  461.  
  462.         if {$compareResult > 0} {
  463.             lvarpop list2
  464.             continue
  465.         }
  466.  
  467.         lappend intersectList [lvarpop list1]
  468.         lvarpop list2
  469.     }
  470.     return $intersectList
  471. }
  472.  
  473.  
  474.  
  475. #@package: TclX-show_procedures showproc showprocs
  476.  
  477. proc showproc {procname} {
  478.     if [lempty [info procs $procname]] {demand_load $procname}
  479.     set arglist [info args $procname]
  480.     set nargs {}
  481.     while {[llength $arglist] > 0} {
  482.         set varg [lvarpop arglist 0]
  483.         if [info default $procname $varg defarg] {
  484.         lappend nargs [list $varg $defarg]
  485.         } else {
  486.         lappend nargs $varg
  487.         }
  488.     }
  489.     format "proc %s \{%s\} \{%s\}\n" $procname $nargs [info body $procname]
  490. }
  491.  
  492. proc showprocs {args} {
  493.     if [lempty $args] { set args [info procs] }
  494.     set out ""
  495.  
  496.     foreach i $args {
  497.     foreach j $i { append out [showproc $j] "\n"}
  498.     }
  499.     return $out
  500. }
  501.  
  502.  
  503. #@package: TclX-stringfile_functions read_file write_file
  504.  
  505. proc read_file {fileName {numBytes {}}} {
  506.     set fp [open $fileName]
  507.     if {$numBytes != ""} {
  508.         set result [read $fp $numBytes]
  509.     } else {
  510.         set result [read $fp]
  511.     }
  512.     close $fp
  513.     return $result
  514. } 
  515.  
  516. proc write_file {fileName args} {
  517.     set fp [open $fileName w]
  518.     foreach string $args {
  519.         puts $fp $string
  520.     }
  521.     close $fp
  522. }
  523.  
  524.  
  525. #@package: TclX-Compatibility execvp
  526.  
  527. proc execvp {progname args} {
  528.     execl $progname $args
  529. }
  530.  
  531. #@package: TclX-convertlib convert_lib
  532.  
  533. proc convert_lib {tclIndex packageLib {ignore {}}} {
  534.     if {[file tail $tclIndex] != "tclIndex"} {
  535.         error "Tail file name numt be `tclIndex': $tclIndex"}
  536.     set srcDir [file dirname $tclIndex]
  537.  
  538.     if {[file extension $packageLib] != ".tlib"} {
  539.         append packageLib ".tlib"}
  540.  
  541.  
  542.     set tclIndexFH [open $tclIndex r]
  543.     while {[gets $tclIndexFH line] >= 0} {
  544.         if {([cindex $line 0] == "#") || ([llength $line] != 2)} {
  545.             continue}
  546.         if {[lsearch $ignore [lindex $line 1]] >= 0} {
  547.             continue}
  548.         lappend entryTable([lindex $line 1]) [lindex $line 0]
  549.     }
  550.     close $tclIndexFH
  551.  
  552.     set libFH [open $packageLib w]
  553.     foreach srcFile [array names entryTable] {
  554.         set srcFH [open $srcDir/$srcFile r]
  555.         puts $libFH "#@package: $srcFile $entryTable($srcFile)\n"
  556.         copyfile $srcFH $libFH
  557.         close $srcFH
  558.     }
  559.     close $libFH
  560.     buildpackageindex $packageLib
  561. }
  562.  
  563. #@package: TclX-profrep profrep
  564.  
  565. proc profrep:summarize {profDataVar stackDepth sumProfDataVar} {
  566.     upvar $profDataVar profData $sumProfDataVar sumProfData
  567.  
  568.     if {(![info exists profData]) || ([catch {array size profData}] != 0)} {
  569.         error "`profDataVar' must be the name of an array returned by the `profile off' command"
  570.     }
  571.     set maxNameLen 0
  572.     foreach procStack [array names profData] {
  573.         if {[llength $procStack] < $stackDepth} {
  574.             set sigProcStack $procStack
  575.         } else {
  576.             set sigProcStack [lrange $procStack 0 [expr {$stackDepth - 1}]]
  577.         }
  578.         set maxNameLen [max $maxNameLen [clength $sigProcStack]]
  579.         if [info exists sumProfData($sigProcStack)] {
  580.             set cur $sumProfData($sigProcStack)
  581.             set add $profData($procStack)
  582.             set     new [expr [lindex $cur 0]+[lindex $add 0]]
  583.             lappend new [expr [lindex $cur 1]+[lindex $add 1]]
  584.             lappend new [expr [lindex $cur 2]+[lindex $add 2]]
  585.             set $sumProfData($sigProcStack) $new
  586.         } else {
  587.             set sumProfData($sigProcStack) $profData($procStack)
  588.         }
  589.     }
  590.     return $maxNameLen
  591. }
  592.  
  593. proc profrep:sort {sumProfDataVar sortKey} {
  594.     upvar $sumProfDataVar sumProfData
  595.  
  596.     case $sortKey {
  597.         {calls} {set keyIndex 0}
  598.         {real}  {set keyIndex 1}
  599.         {cpu}   {set keyIndex 2}
  600.         default {
  601.             error "Expected a sort of: `calls',  `cpu' or ` real'"}
  602.     }
  603.  
  604.  
  605.     foreach procStack [array names sumProfData] {
  606.         set key [format "%016d" [lindex $sumProfData($procStack) $keyIndex]]
  607.         lappend keyProcList [list $key $procStack]
  608.     }
  609.     set keyProcList [lsort $keyProcList]
  610.  
  611.  
  612.     for {set idx [expr [llength $keyProcList]-1]} {$idx >= 0} {incr idx -1} {
  613.         lappend sortedProcList [lindex [lindex $keyProcList $idx] 1]
  614.     }
  615.     return $sortedProcList
  616. }
  617.  
  618.  
  619. proc profrep:print {sumProfDataVar sortedProcList maxNameLen outFile
  620.                     userTitle} {
  621.     upvar $sumProfDataVar sumProfData
  622.     
  623.     if {$outFile == ""} {
  624.         set outFH stdout
  625.     } else {
  626.         set outFH [open $outFile w]
  627.     }
  628.  
  629.  
  630.     set stackTitle "Procedure Call Stack"
  631.     set maxNameLen [max $maxNameLen [clength $stackTitle]]
  632.     set hdr [format "%-${maxNameLen}s %10s %10s %10s" $stackTitle \
  633.                     "Calls" "Real Time" "CPU Time"]
  634.     if {$userTitle != ""} {
  635.         puts $outFH [replicate - [clength $hdr]]
  636.         puts $outFH $userTitle
  637.     }
  638.     puts $outFH [replicate - [clength $hdr]]
  639.     puts $outFH $hdr
  640.     puts $outFH [replicate - [clength $hdr]]
  641.  
  642.  
  643.     foreach procStack $sortedProcList {
  644.         set data $sumProfData($procStack)
  645.         puts $outFH [format "%-${maxNameLen}s %10d %10d %10d" $procStack \
  646.                             [lindex $data 0] [lindex $data 1] [lindex $data 2]]
  647.     }
  648.     if {$outFile != ""} {
  649.         close $outFH
  650.     }
  651. }
  652.  
  653.  
  654. proc profrep {profDataVar sortKey stackDepth {outFile {}} {userTitle {}}} {
  655.     upvar $profDataVar profData
  656.  
  657.     set maxNameLen [profrep:summarize profData $stackDepth sumProfData]
  658.     set sortedProcList [profrep:sort sumProfData $sortKey]
  659.     profrep:print sumProfData $sortedProcList $maxNameLen $outFile $userTitle
  660.  
  661. }
  662.